diff --git a/lib/chibi/binary-record.scm b/lib/chibi/binary-record.scm
new file mode 100644
index 00000000..09889a40
--- /dev/null
+++ b/lib/chibi/binary-record.scm
@@ -0,0 +1,265 @@
+
+;; Record types with user-specified binary formats.
+;; A work in progress, but sufficient for tar files.
+
+(define (assert-read-u8 in i)
+  (let ((i2 (read-u8 in)))
+    (if (not (eqv? i i2))
+        (error "unexpected value: " i i2)
+        i2)))
+
+(define (assert-read-char in ch)
+  (let ((ch2 (read-char in)))
+    (if (not (eqv? ch ch2))
+        (error "unexpected value: " ch ch2)
+        ch2)))
+
+(define (assert-read-string in s)
+  (let ((s2 (read-string (string-length s) in)))
+    (if (not (equal? s s2))
+        (error "unexpected value: " s s2)
+        s2)))
+
+(define (assert-read-bytevector in bv)
+  (let ((bv2 (read-bytevector (bytevector-length bv) in)))
+    (if (not (equal? bv bv2))
+        (error "unexpected value: " bv bv2)
+        bv2)))
+
+(define (assert-read-integer in len radix)
+  (let* ((s (string-trim (read-string len in)
+                         (lambda (ch) (or (eqv? ch #\space) (eqv? ch #\null)))))
+         (n (if (equal? s "") 0 (string->number s radix))))
+    (or n (error "invalid number syntax: " s))))
+
+(define (read-padded-string in len pad)
+  (string-trim-right (read-string len in) pad))
+
+(define (expand-read rename in spec)
+  (case (car spec)
+    ((literal)
+     (let ((val (cadr spec)))
+       (cond ((integer? val) `(,(rename 'assert-read-u8) ,in ,val))
+             ((char? val) `(,(rename 'assert-read-char) ,in ,val))
+             ((string? val) `(,(rename 'assert-read-string) ,in ,val))
+             ((bytevector? val) `(,(rename 'assert-read-bytevector) ,in ,val))
+             (else (error "unknown binary literal: " val)))))
+    ((octal)
+     `(,(rename 'assert-read-integer) ,in ,(cadr spec) 8))
+    ((decimal)
+     `(,(rename 'assert-read-integer) ,in ,(cadr spec) 10))
+    ((hexadecimal)
+     `(,(rename 'assert-read-integer) ,in ,(cadr spec) 16))
+    ((fixed-string)
+     (let ((len (cadr spec)))
+       `(,(rename 'read-string) ,len ,in)))
+    ((padded-string)
+     (let ((len (cadr spec))
+           (pad (if (pair? (cddr spec)) (car (cddr spec)) #\null)))
+       `(,(rename 'read-padded-string) ,in ,len ,pad)))
+    (else
+     (error "unknown binary format: " spec))))
+
+(define (string-pad-left str len . o)
+  (let ((diff (- len (string-length str)))
+        (pad-ch (if (pair? o) (car o) #\space)))
+    (if (positive? diff)
+        (string-append (make-string diff pad-ch) str)
+        str)))
+
+(define (string-pad-right str len . o)
+  (let ((diff (- len (string-length str)))
+        (pad-ch (if (pair? o) (car o) #\space)))
+    (if (positive? diff)
+        (string-append str (make-string diff pad-ch))
+        str)))
+
+(define (write-padded-integer out n radix len left-pad-ch right-pad-ch)
+  (let ((s (string-pad-left (number->string n radix) (- len 1) left-pad-ch)))
+    (cond
+     ((>= (string-length s) len)
+      (error "number too large for width" n radix len))
+     (else
+      (write-string s out)
+      (write-char right-pad-ch out)))))
+
+(define (expand-write rename out val spec)
+  (let ((_if (rename 'if))
+        (_not (rename 'not))
+        (_let (rename 'let))
+        (_string-length (rename 'string-length))
+        (_write-string (rename 'write-string))
+        (_write-bytevector (rename 'write-bytevector))
+        (_error (rename 'error))
+        (_> (rename '>))
+        (_= (rename '=)))
+    (case (car spec)
+      ((literal)
+       (let ((val (cadr spec)))
+         (cond ((integer? val) `(,(rename 'write-u8) ,val ,out))
+               ((char? val) `(,(rename 'write-char) ,val ,out))
+               ((string? val) `(,_write-string ,val ,out))
+               ((bytevector? val) `(,_write-bytevector ,val ,out))
+               (else (error "unknown binary literal: " val)))))
+      ((octal)
+       `(,(rename 'write-padded-integer) ,out ,val 8 ,(cadr spec) #\0 #\null))
+      ((decimal)
+       `(,(rename 'write-padded-integer) ,out ,val 10 ,(cadr spec) #\0 #\null))
+      ((hexadecimal)
+       `(,(rename 'write-padded-integer) ,out ,val 16 ,(cadr spec) #\0 #\null))
+      ((fixed-string)
+       (let ((len (cadr spec)))
+         `(,_if (,_not (,_= ,len (,_string-length ,val)))
+              (,_error "wrong field length: " ,val ,len)
+              (,_write-string ,val ,out))))
+      ((padded-string)
+       (let ((len (cadr spec))
+             (pad (if (pair? (cddr spec)) (car (cddr spec)) #\null)))
+         `(,_let ((l (,_string-length ,val)))
+            (,_if (,_> l ,len)
+                (,_error "field too large: " ,val ,len)
+                (,_write-string (,(rename 'string-pad-right) ,val ,len ,pad)
+                                ,out)))))
+      (else
+       (error "unknown binary format: " spec)))))
+
+(define (expand-assert rename spec x v)
+  (let ((_if (rename 'if))
+        (_not (rename 'not))
+        (_error (rename 'error))
+        (_integer? (rename 'integer?))
+        (_string? (rename 'string?))
+        (_string-length (rename 'string-length))
+        (_> (rename '>)))
+    (case (car spec)
+      ((literal) #t)
+      ((octal decimal hexadecimal)
+       `(,_if (,_not (,_integer? ,v))
+            (,_error "expected an integer" ,v)))
+      ((fixed-string padded-string)
+       (let ((len (cadr spec)))
+         `(,_if (,_not (,_string? ,v))
+              (,_error "expected a string" ,v)
+              (,_if (,_> (,_string-length ,v) ,len)
+                  (,_error "string too long" ,v ,len)))))
+      (else (error "unknown binary format: " spec)))))
+
+(define (expand-default rename spec)
+  (case (car spec)
+    ((literal) (cadr spec))
+    ((octal decimal hexadecimal) 0)
+    ((fixed-string) (make-string (cadr spec) #\space))
+    ((padded-string) "")
+    (else (error "unknown binary format: " spec))))
+
+(define (param-ref ls key . o)
+  (cond ((assq key ls) => cadr) ((pair? o) (car o)) (else #f)))
+
+(define (symbol-append a b)
+  (string->symbol (string-append (symbol->string a) (symbol->string b))))
+
+(define-record-type Field
+  (make-field name get set raw-set spec)
+  field?
+  (name field-name)
+  (get field-get)
+  (set field-set)
+  (raw-set field-raw-set)
+  (spec field-spec))
+
+(define (extract-fields type ls)
+  (let lp ((ls ls) (res '()))
+    (cond
+     ((null? ls)
+      (reverse res))
+     ((not (pair? (car ls)))
+      (lp (cdr ls) (cons (make-field '_ #f #f #f `(literal ,(car ls))) res)))
+     (else
+      (let* ((name (caar ls))
+             (get (or (param-ref (car ls) 'getter)
+                      (and (not (eq? name '_))
+                           (symbol-append type (symbol-append '- name)))))
+             (set (or (param-ref (car ls) 'setter)
+                      (and (not (eq? name '_))
+                           (symbol-append (symbol-append type '-)
+                                          (symbol-append name '-set!)))))
+             (raw-set (and set (symbol-append '% set)))
+             (spec (cadr (car ls))))
+        (lp (cdr ls) (cons (make-field name get set raw-set spec) res)))))))
+
+(define-syntax define-binary-record-type
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (let ((name (cadr expr))
+           (ls (cddr expr)))
+       (if (not (and (identifier? name) (every list? ls)))
+           (error "invalid syntax: " expr))
+       (let* ((type (or (param-ref ls 'type) (symbol-append 'type- name)))
+              (pred (or (param-ref ls 'predicate) (symbol-append name '?)))
+              (make (or (param-ref ls 'make) (symbol-append 'make- name)))
+              (make-spec (if (pair? make) make (list make)))
+              (%make (rename (symbol-append '% (car make-spec))))
+              (%%make (rename (symbol-append '%% (car make-spec))))
+              (reader (or (param-ref ls 'read) (symbol-append 'read- name)))
+              (writer (or (param-ref ls 'write) (symbol-append 'write- name)))
+              (block (assq 'block ls))
+              (_begin (rename 'begin))
+              (_define (rename 'define))
+              (_define-record-type (rename 'define-record-type))
+              (_let (rename 'let)))
+         (if (not block)
+             (error "missing binary record block: " expr))
+         (let* ((fields (extract-fields name (cdr block)))
+                (named-fields (filter (lambda (f) (not (eq? '_ (field-name f))))
+                                      fields)))
+           `(,_begin
+             (,_define ,name ',ls)
+             (,_define-record-type
+              ,type (,%%make) ,pred
+              ,@(map
+                 (lambda (f)
+                   `(,(field-name f) ,(field-get f) ,(field-raw-set f)))
+                 named-fields))
+             ,@(map
+                (lambda (f)
+                  `(,_define (,(field-set f) x v)
+                     ,(expand-assert rename (field-spec f) 'x 'v)
+                     (,(field-raw-set f) x v)))
+                named-fields)
+             (,_define (,%make)
+               (let ((res (,%%make)))
+                 ,@(map
+                    (lambda (f)
+                      `(,(field-raw-set f)
+                        res
+                        ,(expand-default rename (field-spec f))))
+                    named-fields)
+                 res))
+             (,_define ,make-spec
+               (,_let ((res (,%make)))
+                 ,@(map
+                    (lambda (x)
+                      (let ((field (find (lambda (f) (eq? x (field-name f)))
+                                         fields)))
+                        `(,(field-set field) res ,x)))
+                    (cdr make-spec))
+                 res))
+             (,_define (,reader in)
+               (,_let ((res (,%make)))
+                 ,@(map
+                    (lambda (f)
+                      (if (eq? '_ (field-name f))
+                          (expand-read rename 'in (field-spec f))
+                          `(,(field-set f)
+                            res
+                            ,(expand-read rename 'in (field-spec f)))))
+                    fields)
+                 res))
+             (,_define (,writer x out)
+               ,@(map
+                  (lambda (f)
+                    (expand-write rename
+                                  'out
+                                  `(,(field-get f) x)
+                                  (field-spec f)))
+                  fields)))))))))
diff --git a/lib/chibi/binary-record.sld b/lib/chibi/binary-record.sld
new file mode 100644
index 00000000..6b407984
--- /dev/null
+++ b/lib/chibi/binary-record.sld
@@ -0,0 +1,8 @@
+
+(define-library (chibi binary-record)
+  (import (scheme base)
+          (srfi 1) (srfi 9)
+          (chibi io) (chibi string)
+          (only (chibi) identifier? er-macro-transformer))
+  (export define-binary-record-type)
+  (include "binary-record.scm"))