diff --git a/src/ikarus.boot b/src/ikarus.boot
index 5b251e9..7b85ee8 100644
Binary files a/src/ikarus.boot and b/src/ikarus.boot differ
diff --git a/src/libfasl.ss b/src/libfasl.ss
index 463d0c1..a4c5944 100644
--- a/src/libfasl.ss
+++ b/src/libfasl.ss
@@ -237,34 +237,198 @@
     (if (char? x)
         (char->integer x)
         (error who "unexpected eof inside a fasl object")))
+  (define (read-fixnum p)
+    (let ([c0 (char->int (read-char p))]
+          [c1 (char->int (read-char p))]
+          [c2 (char->int (read-char p))]
+          [c3 (char->int (read-char p))])
+      (cond
+        [(fx<= c3 127)
+         (fxlogor (fxlogor (fxsra c0 2) (fxsll c1 6))
+                  (fxlogor (fxsll c2 14) (fxsll c3 22)))]
+        [else
+         (let ([c0 (fxlogand #xFF (fxlognot c0))]
+               [c1 (fxlogand #xFF (fxlognot c1))]
+               [c2 (fxlogand #xFF (fxlognot c2))]
+               [c3 (fxlogand #xFF (fxlognot c3))])
+           (fx- -1 
+             (fxlogor (fxlogor (fxsra c0 2) 
+                               (fxsll c1 6))
+                      (fxlogor (fxsll c2 14) 
+                               (fxsll c3 22)))))])))
+  (define (read-int p)
+    (let ([c0 (char->int (read-char p))]
+          [c1 (char->int (read-char p))]
+          [c2 (char->int (read-char p))]
+          [c3 (char->int (read-char p))])
+      (cond
+        [(fx<= c3 127)
+         (fxlogor (fxlogor c0 (fxsll c1 8))
+                  (fxlogor (fxsll c2 16) (fxsll c3 24)))]
+        [else
+         (let ([c0 (fxlogand #xFF (fxlognot c0))]
+               [c1 (fxlogand #xFF (fxlognot c1))]
+               [c2 (fxlogand #xFF (fxlognot c2))]
+               [c3 (fxlogand #xFF (fxlognot c3))])
+           (fx- -1 
+             (fxlogor (fxlogor c0 
+                               (fxsll c1 8))
+                      (fxlogor (fxsll c2 16) 
+                               (fxsll c3 24)))))]))) 
   (define (do-read p)
-    (define (read)
+    (define marks (make-vector 1 #f))
+    (define (max x y)
+      (if (fx> x y) x y))
+    (define (put-mark m obj)
+      (cond
+        [(fx< m (vector-length marks))
+         (when (vector-ref marks m)
+           (error 'fasl-read "mark ~s set twice" m))
+         (vector-set! marks m obj)]
+        [else
+         (let ([n (vector-length marks)])
+           (let ([v (make-vector 
+                      (max (fx* n 2) (fx+ m 1))
+                      #f)])
+             (let f ([i 0])
+               (cond
+                 [(fx= i n) 
+                  (set! marks v)
+                  (vector-set! marks m obj)]
+                 [else
+                  (vector-set! v i (vector-ref marks i))
+                  (f (fxadd1 i))]))))]))
+    (define (read) (read/mark #f))
+    (define (read-code code-m clos-m)
+      (let* ([code-size (read-int p)]
+             [freevars (read-fixnum p)])
+        (let ([code (make-code code-size freevars)])
+          (when code-m (put-mark code-m code))
+          (let f ([i 0])
+            (unless (fx= i code-size)
+              (code-set! code i (char->int (read-char p)))
+              (f (fxadd1 i))))
+          (cond
+            [clos-m
+             (let ([clos ($code->closure code)])
+               (put-mark clos-m clos)
+               (set-code-reloc-vector! code (read))
+               clos)]
+            [else
+             (set-code-reloc-vector! code (read))
+             code]))))
+    (define (read-thunk m)
+      (let ([c (read-char p)])
+        (case c
+          [(#\x)
+           (read-code #f m)]
+          [(#\<) 
+           (let ([cm (read-int p)])
+             (unless (fx< cm (vector-length marks))
+               (error who "invalid mark ~s\n" m))
+             (let ([code (vector-ref marks cm)])
+               (let ([proc ($code->closure code)])
+                 (when m (put-mark m proc))
+                 proc)))]
+          [(#\>)
+           (let ([cm (read-int p)])
+             (assert-eq? (read-char p) #\x)
+             (read-code cm m))]
+          [else (error who "invalid code header ~s" c)])))
+    (define (read/mark m)
+      (define (nom)
+        (when m (error who "unhandled mark")))
       (let ([h (read-char p)])
         (case h
-          [(#\I)
-           (let ([c0 (char->int (read-char p))]
-                 [c1 (char->int (read-char p))]
-                 [c2 (char->int (read-char p))]
-                 [c3 (char->int (read-char p))])
-             (cond
-               [(fx<= c3 127)
-                (fxlogor (fxlogor (fxsra c0 2) (fxsll c1 6))
-                         (fxlogor (fxsll c2 14) (fxsll c3 22)))]
-               [else
-                (let ([c0 (fxlogand #xFF (fxlognot c0))]
-                      [c1 (fxlogand #xFF (fxlognot c1))]
-                      [c2 (fxlogand #xFF (fxlognot c2))]
-                      [c3 (fxlogand #xFF (fxlognot c3))])
-                  (fx- -1 
-                    (fxlogor (fxlogor (fxsra c0 2) 
-                                      (fxsll c1 6))
-                             (fxlogor (fxsll c2 14) 
-                                      (fxsll c3 22)))))]))]
+          [(#\I) 
+           (nom)
+           (read-fixnum p)]
           [(#\P)
-           (let ([a (read)])
-             (cons a (read)))]
+           (if m
+               (let ([x (cons #f #f)])
+                 (put-mark m x)
+                 (set-car! x (read))
+                 (set-cdr! x (read))
+                 x)
+               (let ([a (read)])
+                 (cons a (read))))]
           [(#\N) '()]
-          [else 
+          [(#\T) #t]
+          [(#\F) #f]
+          [(#\E) (eof-object)]
+          [(#\U) (void)]
+          [(#\S) ;;; string
+           (let ([n (read-int p)])
+             (let ([str (make-string n)])
+               (let f ([i 0])
+                 (unless (fx= i n)
+                   (let ([c (read-char p)])
+                     (string-set! str i c)
+                     (f (fxadd1 i)))))
+               (when m (put-mark m str))
+               str))]
+          [(#\M) ;;; symbol
+           (let ([str (read)])
+             (let ([sym (string->symbol str)])
+               (when m (put-mark m sym))
+               sym))]
+          [(#\G)
+           (let* ([pretty (read)]
+                  [unique (read)])
+             (foreign-call "ikrt_strings_to_gensym" pretty unique))]
+          [(#\V) ;;; vector
+           (let ([n (read-int p)])
+             (let ([v (make-vector n)])
+               (when m (put-mark m v))
+               (let f ([i 0])
+                 (unless (fx= i n)
+                   (vector-set! v i (read))
+                   (f (fxadd1 i))))
+               v))]
+          [(#\x) ;;; code
+           (read-code m #f)]
+          [(#\Q) ;;; thunk
+           (read-thunk m)]
+          [(#\R)
+           (let* ([rtd-name (read)]
+                  [rtd-symbol (read)]
+                  [field-count (read-int p)])
+             (let ([fields
+                    (let f ([i 0])
+                      (cond
+                        [(fx= i field-count) '()]
+                        [else 
+                         (let ([a (read)])
+                           (cons a (f (fxadd1 i))))]))])
+               (let ([rtd (make-record-type 
+                            rtd-name fields rtd-symbol)])
+                 (when m (put-mark m rtd))
+                 rtd)))]
+          [(#\{)
+           (let ([n (read-int p)])
+             (let ([rtd (read)])
+               (let ([x ($make-record rtd n)])
+                 (when m (put-mark m x))
+                 (let f ([i 0])
+                   (unless (fx= i n)
+                     (record-set! x i (read))
+                     (f (fxadd1 i))))
+                 x)))]
+          [(#\C)
+           (let ([c (read-char p)])
+             (cond
+               [(char? c) c]
+               [else
+                (error who "invalid eof inside a fasl object")]))]
+          [(#\>)
+           (let ([m (read-int p)])
+             (read/mark m))]
+          [(#\<)
+           (let ([m (read-int p)])
+             (unless (fx< m (vector-length marks))
+               (error who "invalid mark ~s\n" m))
+             (vector-ref marks m))]
+          [else
            (error who "Unexpected ~s as a fasl object header" h)])))
     (read))
   (primitive-set! '$fasl-read
diff --git a/src/librecord.ss b/src/librecord.ss
index bae25c7..8cec11a 100644
--- a/src/librecord.ss
+++ b/src/librecord.ss
@@ -79,21 +79,40 @@
         [else #f])))
 
   (define make-record-type
-    (lambda (name fields)
-      (unless (string? name)
-        (error 'make-record-type "name must be a string, got ~s" name))
-      (unless (list? fields)
-        (error 'make-record-type "fields must be a list, got ~s" fields))
-      (for-each verify-field fields)
-      (make-rtd name fields #f (gensym name))))
-
+    (case-lambda
+      [(name fields)
+       (unless (string? name)
+         (error 'make-record-type "name must be a string, got ~s" name))
+       (unless (list? fields)
+         (error 'make-record-type "fields must be a list, got ~s" fields))
+       (for-each verify-field fields)
+       (let ([g (gensym name)])
+         (let ([rtd (make-rtd name fields #f g)])
+           (set-top-level-value! g rtd)
+           rtd))]
+      [(name fields g)
+       (unless (string? name)
+         (error 'make-record-type "name must be a string, got ~s" name))
+       (unless (list? fields)
+         (error 'make-record-type "fields must be a list, got ~s" fields))
+       (for-each verify-field fields)
+       (cond
+         [(top-level-bound? g) 
+          (let ([rtd (top-level-value g)])
+            (unless (and (string=? name (record-type-name rtd))
+                         (equal? fields (record-type-field-names rtd)))
+              (error 'make-record-type "definition mismatch"))
+            rtd)]
+         [else
+          (let ([rtd (make-rtd name fields #f g)])
+            (set-top-level-value! g rtd)
+            rtd)])]))
 
   (define record-type-name
     (lambda (rtd)
       (unless (rtd? rtd)
         (error 'record-type-name "~s is not an rtd" rtd))
       (rtd-name rtd)))
- 
 
   (define record-type-symbol
     (lambda (rtd)