diff --git a/scheme/ikarus.fasl.ss b/scheme/ikarus.fasl.ss
index 45c842d..7b05b2c 100644
--- a/scheme/ikarus.fasl.ss
+++ b/scheme/ikarus.fasl.ss
@@ -314,6 +314,28 @@
                            (cons x (f (- n 1))))])))])
              (when m (put-mark m ls))
              ls)]
+          [(#\W) ;;; r6rs record type descriptor
+           (let* ([name    (read)]
+                  [parent  (read)]
+                  [uid     (read)]
+                  [sealed? (read)]
+                  [opaque? (read)]
+                  [n       (read)]
+                  [fields  (make-vector n)])
+             (let f ([i 0])
+               (cond
+                 [(= i n) 
+                  (let ([rtd (make-record-type-descriptor
+                               name parent uid sealed? opaque?
+                               fields)])
+                    (when m (put-mark m rtd))
+                    rtd)]
+                 [else
+                  (let* ([field-mutable? (read)]
+                         [field-name (read)])
+                    (vector-set! fields i 
+                      (list (if field-mutable? 'mutable 'immutable) field-name))
+                    (f (+ i 1)))])))]
           [else
            (die who "Unexpected char as a fasl object header" h)])))
     (read))
diff --git a/scheme/ikarus.fasl.write.ss b/scheme/ikarus.fasl.write.ss
index 6408e69..c69b9dc 100644
--- a/scheme/ikarus.fasl.write.ss
+++ b/scheme/ikarus.fasl.write.ss
@@ -199,35 +199,55 @@
                (f (fxadd1 i) n)))
            (fasl-write-object (code-reloc-vector x) p h m))]
         [(struct? x)
-         (let ([rtd (struct-type-descriptor x)])
-           (cond
-             [(eq? rtd (base-rtd))
-              ;;; rtd record
-              (put-tag #\R p)
-              (let ([names (struct-type-field-names x)]
-                    [m 
-                     (fasl-write-object (struct-type-symbol x) p h
-                       (fasl-write-object (struct-type-name x) p h m))])
-                (write-int (length names) p)
-                (let f ([names names] [m m])
+         (cond
+           [(record-type-descriptor? x)
+            (put-tag #\W p)
+            (let* ([m (fasl-write-object (record-type-name x) p h m)]
+                   [m (fasl-write-object (record-type-parent x) p h m)]
+                   [m (fasl-write-object (record-type-uid x) p h m)])
+              (fasl-write-immediate (record-type-sealed? x) p)
+              (fasl-write-immediate (record-type-opaque? x) p)
+              (let* ([fields (record-type-field-names x)]
+                     [n (vector-length fields)])
+                (fasl-write-immediate n p)
+                (let f ([i 0] [m m])
                   (cond
-                    [(null? names) m]
+                    [(= i n) m]
                     [else
-                     (f (cdr names)
-                        (fasl-write-object (car names) p h m))])))]
-             [else
-              ;;; non-rtd record
-              (put-tag #\{ p)
-              (write-int (length (struct-type-field-names rtd)) p)
-              (let f ([names (struct-type-field-names rtd)] 
-                      [m (fasl-write-object rtd p h m)])
-                (cond
-                  [(null? names) m]
-                  [else
-                   (f (cdr names) 
-                      (fasl-write-object 
-                         ((struct-field-accessor rtd (car names)) x)
-                         p h m))]))]))]
+                     (fasl-write-immediate (record-field-mutable? x i) p)
+                     (f (+ i 1) 
+                        (fasl-write-object (vector-ref fields i) p h m))]))))]
+           [else
+            (let ([rtd (struct-type-descriptor x)])
+              (cond
+                [(eq? rtd (base-rtd))
+                 ;;; rtd record
+                 (put-tag #\R p)
+                 (let ([names (struct-type-field-names x)]
+                       [m 
+                        (fasl-write-object (struct-type-symbol x) p h
+                          (fasl-write-object (struct-type-name x) p h m))])
+                   (write-int (length names) p)
+                   (let f ([names names] [m m])
+                     (cond
+                       [(null? names) m]
+                       [else
+                        (f (cdr names)
+                           (fasl-write-object (car names) p h m))])))]
+                [else
+                 ;;; non-rtd record
+                 (put-tag #\{ p)
+                 (let ([n (struct-length x)])
+                   (write-int n p)
+                   (let f ([i 0] 
+                           [m (fasl-write-object rtd p h m)])
+                     (cond
+                       [(= i n) m]
+                       [else
+                        (f (+ i 1)
+                           (fasl-write-object 
+                              (struct-ref x i)
+                              p h m))])))]))])]
         [(procedure? x)
          (put-tag #\Q p)
          (fasl-write-object ($closure-code x) p h m)]
@@ -313,23 +333,32 @@
               (make-graph ($code-annotation x) h)
               (make-graph (code-reloc-vector x) h)]
              [(struct? x)
-              (when (eq? x (base-rtd))
-                (die 'fasl-write "base-rtd is not writable"))
-              (let ([rtd (struct-type-descriptor x)])
-                (cond
-                  [(eq? rtd (base-rtd))
-                   ;;; this is an rtd
-                   (make-graph (struct-type-name x) h)
-                   (make-graph (struct-type-symbol x) h)
-                   (for-each (lambda (x) (make-graph x h))
-                     (struct-type-field-names x))]
-                  [else
-                   ;;; this is a record
-                   (make-graph rtd h)
-                   (for-each 
-                     (lambda (name) 
-                       (make-graph ((struct-field-accessor rtd name) x) h))
-                     (struct-type-field-names rtd))]))]
+              (cond
+                [(eq? x (base-rtd))
+                 (die 'fasl-write "base-rtd is not writable")]
+                [(record-type-descriptor? x) 
+                 (make-graph (record-type-name x) h)
+                 (make-graph (record-type-parent x) h)
+                 (make-graph (record-type-uid x) h)
+                 (vector-for-each 
+                   (lambda (x) (make-graph x h))
+                   (record-type-field-names x))]
+                [else
+                 (let ([rtd (struct-type-descriptor x)])
+                   (cond
+                     [(eq? rtd (base-rtd))
+                      ;;; this is a struct rtd
+                      (make-graph (struct-type-name x) h)
+                      (make-graph (struct-type-symbol x) h)
+                      (for-each (lambda (x) (make-graph x h))
+                        (struct-type-field-names x))]
+                     [else
+                      ;;; this is a struct
+                      (make-graph rtd h)
+                      (let f ([i 0] [n (struct-length x)])
+                        (unless (= i n) 
+                          (make-graph (struct-ref x i) h)
+                          (f (+ i 1) n)))]))])]
              [(procedure? x)
               (let ([code ($closure-code x)])
                 (unless (fxzero? (code-freevars code))
diff --git a/scheme/ikarus.records.procedural.ss b/scheme/ikarus.records.procedural.ss
index 292b673..1ba95e5 100644
--- a/scheme/ikarus.records.procedural.ss
+++ b/scheme/ikarus.records.procedural.ss
@@ -75,7 +75,11 @@
 
   (define (record-type-uid x)
     (if (rtd? x)
-        (rtd-uid x)
+        (or (rtd-uid x)
+            (let ([g (gensym)])
+              (set-rtd-uid! x g) 
+              (intern-rtd! g x)
+              g))
         (die 'record-type-uid "not an rtd" x)))
 
   (define (record-type-sealed? x)
@@ -90,7 +94,7 @@
 
   (define (record-type-generative? x)
     (if (rtd? x)
-        (not (rtd-sealed? x))
+        (not (rtd-sealed? x)) ;;; FIXME: bogus?
         (die 'record-type-generative? "not an rtd" x)))
 
   (define (record-type-field-names x)