diff --git a/bin/ikarus b/bin/ikarus
index 78ea212..88e4a9f 100755
Binary files a/bin/ikarus and b/bin/ikarus differ
diff --git a/bin/ikarus-symbol-table.c b/bin/ikarus-symbol-table.c
index 2df3b02..b6c5e4b 100644
--- a/bin/ikarus-symbol-table.c
+++ b/bin/ikarus-symbol-table.c
@@ -61,6 +61,7 @@ ik_make_symbol(ikp str, ikp ustr, ikpcb* pcb){
 static ikp 
 ik_make_symbol(ikp str, ikp ustr, ikpcb* pcb){
   ikp sym = ik_alloc(pcb, symbol_record_size) + record_tag;
+  ref(sym, -record_tag) = symbol_record_tag;
   ref(sym, off_symbol_record_string)  = str;
   ref(sym, off_symbol_record_ustring) = ustr;
   ref(sym, off_symbol_record_value)   = unbound_object;
diff --git a/src/ikarus.boot b/src/ikarus.boot
index 20143f8..1693002 100644
Binary files a/src/ikarus.boot and b/src/ikarus.boot differ
diff --git a/src/ikarus.compiler.ss b/src/ikarus.compiler.ss
index 0ea8ef8..54d7af0 100644
--- a/src/ikarus.compiler.ss
+++ b/src/ikarus.compiler.ss
@@ -2324,7 +2324,7 @@
        (let ([x (make-primcall op (map Expr arg*))])
          (case op
            [(cons) (check-const pair-size x)]
-           [($make-symbol) (check-const symbol-size x)]
+           [($make-symbol) (check-const symbol-record-size x)]
            [($make-tcbucket) (check-const tcbucket-size x)]
            [($frame->continuation $code->closure) 
             (check-const 
@@ -2932,19 +2932,28 @@
   (define wordsize  4)
   (define wordshift 2)
   
-  (define symbol-mask 7)
-  (define symbol-tag 2)
-  (define disp-symbol-string          0)
-  (define disp-symbol-unique-string   4)
-  (define disp-symbol-value           8)
-  (define disp-symbol-plist          12)
-  (define disp-symbol-system-value   16)
-  (define disp-symbol-function       20)
-  (define disp-symbol-error-function 24)
-  (define disp-symbol-unused         28)
-  (define symbol-size                32)
+  ;(define symbol-mask 7)
+  ;(define symbol-tag 2)
+  ;(define disp-symbol-string          0)
+  ;(define disp-symbol-unique-string   4)
+  ;(define disp-symbol-value           8)
+  ;(define disp-symbol-plist          12)
+  ;(define disp-symbol-system-value   16)
+  ;(define disp-symbol-function       20)
+  ;(define disp-symbol-error-function 24)
+  ;(define disp-symbol-unused         28)
+  ;(define symbol-size                32)
 
+  (define symbol-record-tag #x5F)
+  (define disp-symbol-record-string  4)
+  (define disp-symbol-record-ustring 8)
+  (define disp-symbol-record-value  12)
+  (define disp-symbol-record-proc   16)
+  (define disp-symbol-record-plist  20)
+  (define symbol-record-size  24)
   
+  (define record-tag  5)
+  (define record-mask 7)
 
   (define vector-tag 5)
   (define vector-mask 7)
@@ -3098,7 +3107,7 @@
        (unless (symbol? x) 
          (error 'primitive-location 
             "~s is not a valid location for ~s" x op))
-       (mem (fx- disp-symbol-value symbol-tag) (obj x)))]
+       (mem (fx- disp-symbol-record-value record-tag) (obj x)))]
     [else
      (error 'compile "cannot find location of primitive ~s" op)]))
 
@@ -3217,7 +3226,9 @@
      [(pair?)      (type-pred pair-mask pair-tag rand* Lt Lf ac)]
      [(char?)      (type-pred char-mask char-tag rand* Lt Lf ac)]
      [(string?)    (type-pred string-mask string-tag rand* Lt Lf ac)]
-     [(symbol?)    (type-pred symbol-mask symbol-tag rand* Lt Lf ac)]
+     [(symbol?)    
+      (indirect-type-pred vector-mask vector-tag #f
+         symbol-record-tag rand* Lt Lf ac)]
      [(procedure?) (type-pred closure-mask closure-tag rand* Lt Lf ac)]
      [(boolean?)   (type-pred bool-mask bool-tag rand* Lt Lf ac)]
      [(null?)      (type-pred #f nil rand* Lt Lf ac)]
@@ -3641,11 +3652,11 @@
       [($string-length) 
        (indirect-ref arg* (fx- disp-string-length string-tag) ac)]
       [($symbol-string) 
-       (indirect-ref arg* (fx- disp-symbol-string symbol-tag) ac)]
+       (indirect-ref arg* (fx- disp-symbol-record-string record-tag) ac)]
       [($symbol-unique-string) 
-       (indirect-ref arg* (fx- disp-symbol-unique-string symbol-tag) ac)]
+       (indirect-ref arg* (fx- disp-symbol-record-ustring record-tag) ac)]
       [($symbol-value) 
-       (indirect-ref arg* (fx- disp-symbol-value symbol-tag) ac)]
+       (indirect-ref arg* (fx- disp-symbol-record-value record-tag) ac)]
       [($tcbucket-key) 
        (indirect-ref arg* (fx- disp-tcbucket-key vector-tag) ac)]
       [($tcbucket-val) 
@@ -3673,7 +3684,7 @@
          (sall (int fx-shift) eax)
          ac)]
       [($symbol-plist) 
-       (indirect-ref arg* (fx- disp-symbol-plist symbol-tag) ac)]
+       (indirect-ref arg* (fx- disp-symbol-record-plist record-tag) ac)]
       [($record-rtd) 
        (indirect-ref arg* (fx- disp-record-rtd record-ptag) ac)]
       [($constant-ref)
@@ -3716,7 +3727,7 @@
               (cond
                 [(symbol? v)
                  (list* 
-                   (movl (mem (fx- disp-symbol-value symbol-tag) (obj v)) eax)
+                   (movl (mem (fx- disp-symbol-record-value record-tag) (obj v)) eax)
                    (movl (obj v) ebx)
                    (cmpl (int unbound) eax)
                    (je (label (sl-top-level-value-error-label)))
@@ -3730,10 +3741,13 @@
             (NonTail x
               (list* 
                 (movl eax ebx)
-                (andl (int symbol-mask) eax)
-                (cmpl (int symbol-tag) eax)
+                (andl (int record-mask) eax)
+                (cmpl (int record-tag) eax)
                 (jne (label (sl-top-level-value-error-label)))
-                (movl (mem (fx- disp-symbol-value symbol-tag) ebx) eax)
+                (movl (mem (- record-tag) ebx) eax)
+                (cmpl (int symbol-record-tag) eax)
+                (jne (label (sl-top-level-value-error-label)))
+                (movl (mem (fx- disp-symbol-record-value record-tag) ebx) eax)
                 (cmpl (int unbound) eax)
                 (je (label (sl-top-level-value-error-label)))
                 ac))]))]
@@ -3847,18 +3861,16 @@
                           (mem (fx- disp-cdr (fx+ pair-tag pair-size)) apr))
                       (f b (car d) (cdr d)))))))])]
       [($make-symbol)
-       (list* (movl (Simple (car arg*)) eax)
-              (movl eax (mem disp-symbol-string apr))
-              (movl (int 0) (mem disp-symbol-unique-string apr))
-              (movl (int unbound) (mem disp-symbol-value apr))
-              (movl (int nil) (mem disp-symbol-plist apr))
-              (movl (int unbound) (mem disp-symbol-system-value apr))
-              (movl (int 0) (mem disp-symbol-function apr))
-              (movl (int 0) (mem disp-symbol-error-function apr))
-              (movl (int 0) (mem disp-symbol-unused apr))
+       (list* (movl (int symbol-record-tag) (mem 0 apr))
+              (movl (Simple (car arg*)) eax)
+              (movl eax (mem disp-symbol-record-string apr))
+              (movl (int 0) (mem disp-symbol-record-ustring apr))
+              (movl (int unbound) (mem disp-symbol-record-value apr))
+              (movl (int 0) (mem disp-symbol-record-proc apr))
+              (movl (int nil) (mem disp-symbol-record-plist apr))
               (movl apr eax)
-              (addl (int symbol-tag) eax)
-              (addl (int (align symbol-size)) apr)
+              (addl (int record-tag) eax)
+              (addl (int (align symbol-record-size)) apr)
               ac)]
       [($make-port/input)  (do-make-port input-port-tag arg* ac)]
       [($make-port/output) (do-make-port output-port-tag arg* ac)]
@@ -4137,11 +4149,9 @@
       [($set-symbol-value!) 
        (list* (movl (Simple (car arg*)) eax)
               (movl (Simple (cadr arg*)) ebx)
-              (movl ebx (mem (fx- disp-symbol-value symbol-tag) eax))
-              (movl (mem (fx- disp-symbol-error-function symbol-tag) eax) ebx)
-              (movl ebx (mem (fx- disp-symbol-function symbol-tag) eax))
+              (movl ebx (mem (fx- disp-symbol-record-value record-tag) eax))
                ;;; record side effect
-               (addl (int (fx- disp-symbol-value symbol-tag)) eax)
+               (addl (int (fx- disp-symbol-record-value record-tag)) eax)
                (shrl (int pageshift) eax)
                (sall (int wordshift) eax)
                (addl (pcb-ref 'dirty-vector) eax)
@@ -4150,9 +4160,9 @@
       [($set-symbol-plist!) 
        (list* (movl (Simple (car arg*)) eax)
               (movl (Simple (cadr arg*)) ebx)
-              (movl ebx (mem (fx- disp-symbol-plist symbol-tag) eax))
+              (movl ebx (mem (fx- disp-symbol-record-plist record-tag) eax))
                ;;; record side effect
-               (addl (int (fx- disp-symbol-plist symbol-tag)) eax)
+               (addl (int (fx- disp-symbol-record-plist record-tag)) eax)
                (shrl (int pageshift) eax)
                (sall (int wordshift) eax)
                (addl (pcb-ref 'dirty-vector) eax)
@@ -4161,9 +4171,9 @@
       [($set-symbol-unique-string!) 
        (list* (movl (Simple (car arg*)) eax)
               (movl (Simple (cadr arg*)) ebx)
-              (movl ebx (mem (fx- disp-symbol-unique-string symbol-tag) eax))
+              (movl ebx (mem (fx- disp-symbol-record-ustring record-tag) eax))
                ;;; record side effect
-               (addl (int (fx- disp-symbol-unique-string symbol-tag)) eax)
+               (addl (int (fx- disp-symbol-record-ustring record-tag)) eax)
                (shrl (int pageshift) eax)
                (sall (int wordshift) eax)
                (addl (pcb-ref 'dirty-vector) eax)
@@ -4172,9 +4182,9 @@
       [($set-symbol-string!) 
        (list* (movl (Simple (car arg*)) eax)
               (movl (Simple (cadr arg*)) ebx)
-              (movl ebx (mem (fx- disp-symbol-string symbol-tag) eax))
+              (movl ebx (mem (fx- disp-symbol-record-string record-tag) eax))
                ;;; record side effect
-               (addl (int (fx- disp-symbol-string symbol-tag)) eax)
+               (addl (int (fx- disp-symbol-record-string record-tag)) eax)
                (shrl (int pageshift) eax)
                (sall (int wordshift) eax)
                (addl (pcb-ref 'dirty-vector) eax)
diff --git a/src/ikarus.fasl.write.ss b/src/ikarus.fasl.write.ss
new file mode 100644
index 0000000..64d510f
--- /dev/null
+++ b/src/ikarus.fasl.write.ss
@@ -0,0 +1,205 @@
+
+(library (ikarus fasl write)
+  (export fasl-write)
+  (import
+    (ikarus system $codes)
+    (ikarus system $records)
+    (ikarus code-objects)
+    (except (ikarus) fasl-write))
+
+  (define write-fixnum 
+    (lambda (x p)
+      (unless (fixnum? x) (error 'write-fixnum "not a fixnum ~s" x))
+      (write-char (integer->char (fxsll (fxlogand x #x3F) 2)) p)
+      (write-char (integer->char (fxlogand (fxsra x 6) #xFF)) p)
+      (write-char (integer->char (fxlogand (fxsra x 14) #xFF)) p)
+      (write-char (integer->char (fxlogand (fxsra x 22) #xFF)) p)))
+  (define write-int 
+    (lambda (x p)
+      (unless (fixnum? x) (error 'write-int "not a fixnum ~s" x))
+      (write-char (integer->char (fxlogand x #xFF)) p)
+      (write-char (integer->char (fxlogand (fxsra x 8) #xFF)) p)
+      (write-char (integer->char (fxlogand (fxsra x 16) #xFF)) p)
+      (write-char (integer->char (fxlogand (fxsra x 24) #xFF)) p)))
+  
+  (define fasl-write-immediate
+    (lambda (x p)
+      (cond
+        [(null? x) (write-char #\N p)]
+        [(fixnum? x) 
+         (write-char #\I p)
+         (write-fixnum x p)]
+        [(char? x)
+         (write-char #\C p)
+         (write-char x p)]
+        [(boolean? x)
+         (write-char (if x #\T #\F) p)]
+        [(eof-object? x) (write-char #\E p)]
+        [(eq? x (void)) (write-char #\U p)]
+        [else (error 'fasl-write "~s is not a fasl-writable immediate" x)])))
+  
+  (define do-write
+    (lambda (x p h m)
+      (cond
+        [(pair? x)   
+         (write-char #\P p)
+         (fasl-write-object (cdr x) p h
+           (fasl-write-object (car x) p h m))]
+        [(vector? x)
+         (write-char #\V p)
+         (write-int (vector-length x) p)
+         (let f ([x x] [i 0] [n (vector-length x)] [m m])
+           (cond
+             [(fx= i n) m]
+             [else
+              (f x (fxadd1 i) n
+                 (fasl-write-object (vector-ref x i) p h m))]))]
+        [(string? x) 
+         (write-char #\S p)
+         (write-int (string-length x) p)
+         (let f ([x x] [i 0] [n (string-length x)])
+           (cond
+             [(fx= i n) m]
+             [else
+              (write-char (string-ref x i) p)
+              (f x (fxadd1 i) n)]))]
+        [(gensym? x)
+         (write-char #\G p)
+         (fasl-write-object (gensym->unique-string x) p h
+           (fasl-write-object (symbol->string x) p h m))]
+        [(symbol? x) 
+         (write-char #\M p)
+         (fasl-write-object (symbol->string x) p h m)]
+        [(code? x)
+         (write-char #\x p)
+         (write-int (code-size x) p)
+         (write-fixnum (code-freevars x) p)
+         (let f ([i 0] [n (code-size x)])
+           (unless (fx= i n)
+             (write-char (integer->char (code-ref x i)) p)
+             (f (fxadd1 i) n)))
+         (fasl-write-object (code-reloc-vector x) p h m)]
+        [(record? x)
+         (let ([rtd (record-type-descriptor x)])
+           (cond
+             [(eq? rtd (base-rtd))
+              ;;; rtd record
+              (write-char #\R p)
+              (let ([names (record-type-field-names x)]
+                    [m 
+                     (fasl-write-object (record-type-symbol x) p h
+                       (fasl-write-object (record-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
+              (write-char #\{ p)
+              (write-int (length (record-type-field-names rtd)) p)
+              (let f ([names (record-type-field-names rtd)] 
+                      [m (fasl-write-object rtd p h m)])
+                (cond
+                  [(null? names) m]
+                  [else
+                   (f (cdr names) 
+                      (fasl-write-object 
+                         ((record-field-accessor rtd (car names)) x)
+                         p h m))]))]))]
+        [(procedure? x)
+         (write-char #\Q p)
+         (fasl-write-object ($closure-code x) p h m)]
+        [else (error 'fasl-write "~s is not fasl-writable" x)])))
+  (define fasl-write-object 
+    (lambda (x p h m)
+      (cond
+        [(immediate? x) (fasl-write-immediate x p) m]
+        [(get-hash-table h x #f) =>
+         (lambda (mark)
+           (unless (fixnum? mark)
+             (error 'fasl-write "BUG: invalid mark ~s" mark))
+           (cond
+             [(fx= mark 0) ; singly referenced
+              (do-write x p h m)]
+             [(fx> mark 0) ; marked but not written
+              (put-hash-table! h x (fx- 0 m))
+              (write-char #\> p)
+              (write-int m p)
+              (do-write x p h (fxadd1 m))]
+             [else
+              (write-char #\< p)
+              (write-int (fx- 0 mark) p)
+              m]))]
+        [else (error 'fasl-write "BUG: not in hash table ~s" x)]))) 
+  (define make-graph
+    (lambda (x h)
+      (unless (immediate? x)
+        (cond
+          [(get-hash-table h x #f) =>
+           (lambda (i) 
+             (put-hash-table! h x (fxadd1 i)))]
+          [else
+           (put-hash-table! h x 0)
+           (cond
+             [(pair? x) 
+              (make-graph (car x) h)
+              (make-graph (cdr x) h)]
+             [(vector? x)
+              (let f ([x x] [i 0] [n (vector-length x)])
+                (unless (fx= i n) 
+                  (make-graph (vector-ref x i) h)
+                  (f x (fxadd1 i) n)))]
+             [(symbol? x) 
+              (make-graph (symbol->string x) h)
+              (when (gensym? x) (make-graph (gensym->unique-string x) h))]
+             [(string? x) (void)]
+             [(code? x) 
+              (make-graph (code-reloc-vector x) h)]
+             [(record? x)
+              (when (eq? x (base-rtd))
+                (error 'fasl-write "base-rtd is not writable"))
+              (let ([rtd (record-type-descriptor x)])
+                (cond
+                  [(eq? rtd (base-rtd))
+                   ;;; this is an rtd
+                   (make-graph (record-type-name x) h)
+                   (make-graph (record-type-symbol x) h)
+                   (for-each (lambda (x) (make-graph x h))
+                     (record-type-field-names x))]
+                  [else
+                   ;;; this is a record
+                   (make-graph rtd h)
+                   (for-each 
+                     (lambda (name) 
+                       (make-graph ((record-field-accessor rtd name) x) h))
+                     (record-type-field-names rtd))]))]
+             [(procedure? x)
+              (let ([code ($closure-code x)])
+                (unless (fxzero? (code-freevars code))
+                  (error 'fasl-write
+                         "Cannot write a non-thunk procedure; the one given has ~s free vars"
+                         (code-freevars code)))
+                (make-graph code h))]
+             [else (error 'fasl-write "~s is not fasl-writable" x)])]))))
+  (define fasl-write-to-port
+    (lambda (x port)
+      (let ([h (make-hash-table)])
+         (make-graph x h)
+         (write-char #\# port)
+         (write-char #\@ port)
+         (write-char #\I port)
+         (write-char #\K port)
+         (write-char #\0 port)
+         (write-char #\1 port)
+         (fasl-write-object x port h 1)
+         (void))))
+  (define fasl-write
+     (case-lambda 
+       [(x) (fasl-write-to-port x (current-output-port))]
+       [(x port)
+        (unless (output-port? port)
+          (error 'fasl-write "~s is not an output port" port))
+        (fasl-write-to-port x port)])))
diff --git a/src/makefile.ss b/src/makefile.ss
index a37c7f1..0f03823 100755
--- a/src/makefile.ss
+++ b/src/makefile.ss
@@ -8,7 +8,6 @@
                 current-primitive-locations
                 compile-core-expr-to-port))
 
-;(import (ikarus) (ikarus system $bootstrap))
 
 (define scheme-library-files
   ;;; Listed in the order in which they're loaded.
@@ -712,46 +711,6 @@
        code)))
 
 
-;;; (define (install-system-libraries export-subst export-env)
-;;;   (define (install legend-entry)
-;;;     (let ([key (car legend-entry)]
-;;;           [name (cadr legend-entry)]
-;;;           [visible? (caddr legend-entry)]) 
-;;;       (let ([id     (gensym)]
-;;;             [name       name]
-;;;             [version     '()]
-;;;             [import-libs '()]
-;;;             [visit-libs  '()]
-;;;             [invoke-libs '()])
-;;;         (let-values ([(subst env)
-;;;                       (if (equal? name '(ikarus system $all)) 
-;;;                           (values export-subst export-env)
-;;;                           (values
-;;;                             (get-export-subset key export-subst)
-;;;                             '()))])
-;;;           (install-library 
-;;;              id name version import-libs visit-libs invoke-libs
-;;;              subst env void void visible?)))))
-;;;   (for-each install library-legend))
-
-;  (let ([code `(library (ikarus primlocs)
-;                  (export) ;;; must be empty
-;                  (import 
-;                    (only (ikarus library-manager)
-;                          install-library)
-;                    (only (ikarus.compiler)
-;                          current-primitive-locations)
-;                    (ikarus))
-;                  (current-primitive-locations 
-;                    (lambda (x) 
-;                      (cond
-;                        [(assq x ',primlocs) => cdr]
-;                        [else #f])))
-;                  ,@(map build-library library-legend))])
-;    (let-values ([(code empty-subst empty-env)
-;                  (boot-library-expand code)])
-;       code)))
-
 
 
 
@@ -780,21 +739,6 @@
 
 (verify-map)
 
-;;; (let* ([names (append (map car ikarus-system-macros)
-;;;                       (map car ikarus-procedures-map))]
-;;;        [labels (map (lambda (x) (gensym "boot")) names)]
-;;;        [bindings 
-;;;          (append (map cadr ikarus-system-macros)
-;;;                  (map (lambda (x) 
-;;;                         (cons 'core-prim (car x)))
-;;;                       ikarus-procedures-map))]
-;;;        [subst (map cons names labels)]
-;;;        [env (map cons labels bindings)])
-;;;   (install-system-libraries subst env))
-;;; 
-;;; (printf "installed base libraries ~s\n"
-;;;         (installed-libraries))
-
 (time-it "the entire bootstrap process"
   (lambda ()
     (let-values ([(core* locs)