e-rtd parent-struct args))

    (if (and parent (struct-ref parent rtd-index-sealed?))
	(r6rs-raise (make-assertion-violation)))

    (let ((matching-rtd (and uid (hashq-ref uid-table uid)))
	  (opaque? (or opaque? (and parent (struct-ref 
					    parent rtd-index-opaque?)))))
      (if matching-rtd
	  (if (equal? (list name 
			    parent 
			    sealed? 
			    opaque?                            
			    field-names
                            fields-bit-field)
		      (list (struct-ref matching-rtd rtd-index-name)
			    (struct-ref matching-rtd rtd-index-parent)
			    (struct-ref matching-rtd rtd-index-sealed?)
			    (struct-ref matching-rtd rtd-index-opaque?)
			    (struct-ref matching-rtd rtd-index-field-names)
                            (struct-ref matching-rtd 
                                        rtd-index-field-bit-field)))
	      matching-rtd
	      (r6rs-raise (make-assertion-violation)))
          
	  (let ((rtd (make-struct/no-tail
                      record-type-vtable

                      fields-layout
                      (lambda (obj port)
                        (simple-format 
                         port "#<r6rs:record:~A>" name))
				  
                      name
                      uid
                      parent 
                      sealed? 
                      opaque?
				  
                      private-record-predicate
                      field-names
                      fields-bit-field
                      field-binder)))
	    (set! late-rtd rtd)
	    (if uid (hashq-set! uid-table uid rtd))
	    rtd))))

  (define (record-type-descriptor? obj)
    (and (struct? obj) (eq? (struct-vtable obj) record-type-vtable)))

  (define (make-record-constructor-descriptor rtd 
					      parent-constructor-descriptor
					      protocol)
    (define rtd-arity (vector-length (struct-ref rtd rtd-index-field-names)))
    (define (default-inherited-protocol n)
      (lambda args
	(receive 
          (n-args p-args) 
	  (split-at args (- (length args) rtd-arity))
	  (let ((p (apply n n-args)))
	    (apply p p-args)))))
    (define (default-protocol p) p)
    
    (let* ((prtd (struct-ref rtd rtd-index-parent))
	   (pcd (or parent-constructor-descriptor
		    (and=> prtd (lambda (d) (make-record-constructor-descriptor 
					     prtd #f #f)))))
	   (prot (or protocol (if pcd 
				  default-inherited-protocol 
				  default-protocol))))
      (make-struct/no-tail record-constructor-vtable rtd pcd prot)))

  (define (record-constructor rctd)
    (let* ((rtd (struct-ref rctd rctd-index-rtd))
	   (parent-rctd (struct-ref rctd rctd-index-parent))
	   (protocol (struct-ref rctd rctd-index-protocol)))
      (protocol 
       (if parent-rctd
	   (let ((parent-record-constructor (record-constructor parent-rctd))
		 (parent-rtd (struct-ref parent-rctd rctd-index-rtd)))
	     (lambda args
	       (let ((struct (apply parent-record-constructor args)))
		 (lambda args
		   (apply (struct-ref rtd rtd-index-field-binder)
			  (cons struct args))))))
	   (lambda args (apply (struct-ref rtd rtd-index-field-binder)
			       (cons #f args)))))))
		    
  (define (record-predicate rtd) (struct-ref rtd rtd-index-predicate))

  (define (record-accessor rtd k)
    (define (record-accessor-inner obj)
      (if (eq? (struct-vtable obj) rtd)
	  (struct-ref obj (+ k 1))
          (and=> (struct-ref obj 0) record-accessor-inner)))
    (lambda (obj) 
      (if (not (record-internal? obj))
          (r6rs-raise (make-assertion-violation)))
      (record-accessor-inner obj)))

  (define (record-mutator rtd k)
    (define (record-mutator-inner obj val)
      (and obj (or (and (eq? (struct-vtable obj) rtd)
                        (struct-set! obj (+ k 1) val))
                   (record-mutator-inner (struct-ref obj 0) val))))
    (let ((bit-field (struct-ref rtd rtd-index-field-bit-field)))
      (if (zero? (logand bit-field (ash 1 k)))
	  (r6rs-raise (make-assertion-violation))))
    (lambda (obj val) (record-mutator-inner obj val)))

  ;; Condition types that are used in the current library.  These are defined
  ;; here and not in (rnrs conditions) to avoid a circular dependency.

  (define &condition (make-record-type-descriptor '&condition #f #f #f #f '#()))
  (define &condition-constructor-descriptor 
    (make-record-constructor-descriptor &condition #f #f))

  (define &serious (make-record-type-descriptor 
		    '&serious &condition #f #f #f '#()))
  (define &serious-constructor-descriptor
    (make-record-constructor-descriptor 
     &serious &condition-constructor-descriptor #f))

  (define make-serious-condition 
    (record-constructor &serious-constructor-descriptor))

  (define &violation (make-record-type-descriptor
		      '&violation &serious #f #f #f '#()))
  (define &violation-constructor-descriptor
    (make-record-constructor-descriptor 
     &violation &serious-constructor-descriptor #f))
  (define make-violation (record-constructor &violation-constructor-descriptor))

  (define &assertion (make-record-type-descriptor
		      '&assertion &violation #f #f #f '#()))
  (define make-assertion-violation 
    (record-constructor 
     (make-record-constructor-descriptor
      &assertion &violation-constructor-descriptor #f)))

  ;; Exception wrapper type, along with a wrapping `throw' implementation.
  ;; These are used in the current library, and so they are defined here and not
  ;; in (rnrs exceptions) to avoid a circular dependency.

  (define &raise-object-wrapper
    (make-record-type-descriptor '&raise-object-wrapper #f #f #f #f
				 '#((immutable obj) (immutable continuation))))
  (define make-raise-object-wrapper 
    (record-constructor (make-record-constructor-descriptor 
			 &raise-object-wrapper #f #f)))
  (define raise-object-wrapper? (record-predicate &raise-object-wrapper))
  (define raise-object-wrapper-obj (record-accessor &raise-object-wrapper 0))
  (define raise-object-wrapper-continuation 
    (record-accessor &raise-object-wrapper 1))

  (define (r6rs-raise obj) 
    (throw 'r6rs:exception (make-raise-object-wrapper obj #f)))
  (define (r6rs-raise-continuable obj)
    (define (r6rs-raise-continuable-internal continuation)
      (throw 'r6rs:exception (make-raise-object-wrapper obj continuation)))
    (call/cc r6rs-raise-continuable-internal))
)