1 files changed, 40 insertions, 21 deletions

diff --git a/lib/zambyte/meta/json.sld b/lib/zambyte/meta/json.sld
index bedbc4a..afac535 100644
--- a/lib/zambyte/meta/json.sld
+++ b/lib/zambyte/meta/json.sld
@@ -2,9 +2,11 @@
   ;; portable
   (export json
 	  define-json-record-type
+	  json->typeless-json
 	  json-ref
 	  json-value?
 
+	  json-record-from-string-allow-missing-keys
 	  json-key-not-found)
   ;; non-portable
   (export json-object
@@ -78,37 +80,54 @@
 	    predicate
 	    field-declarations ...)
 	 (begin
-	   (define (constructor fields ...)
-	     (make-json-record 'type
-			       (json-object `(fields . ,fields) ...)
-			       from-json-string
-			       (list (get-accessor field-declarations) ...)
-			       (list (get-mutator field-declarations) ...)))
-
-	   (define (predicate obj)
-	     (cond
-	      ((json-record? obj) (eq? (json-record->name obj) 'type))
-	      ((json-object? obj) (and (json-object-contains-key? obj 'fields) ...))
-	      (else #f)))
-
-	   (define (from-json-string str)
-	     (let ((json (string->json str)))
-	       (parameterize ((json-key-not-found
-			       (lambda ()
-				 (error "key not found in json string when converting to a record" 'type))))
-		 (constructor (json-object-ref json 'fields) ...))))
-
+	   (define-values (constructor predicate from-json-string)
+	     ((lambda ()
+		(define-record-type type
+		  (make-tag)
+		  pred?)
+		(define tag (make-tag))
+		(define (constructor fields ...)
+		  (make-json-record 'type
+				    tag
+				    (json-object `(fields . ,fields) ...)
+				    from-json-string
+				    (list (get-accessor field-declarations) ...)
+				    (list (get-mutator field-declarations) ...)))
+
+		(define (predicate obj)
+		  (cond
+		   ((json-record? obj) (pred? (json-record->tag obj)))
+		   ((json-object? obj) (and (json-object-contains-key? obj 'fields) ...))
+		   (else #f)))
+
+		(define (from-json-string str)
+		  (let ((json (string->json str)))
+		    (if (json-record-from-string-allow-missing-keys)
+			(make-json-record 'type
+					  tag
+					  (string->json str)
+					  from-json-string
+					  (list (get-accessor field-declarations) ...)
+					  (list (get-mutator field-declarations) ...))
+			(parameterize ((json-key-not-found
+					(lambda ()
+					  (error "key not found in json string when converting to a record" 'type))))
+			  (constructor (json-object-ref json 'fields) ...)))))
+		(values constructor predicate from-json-string))))
 	   (handle-field-declarations field-declarations) ...))))
 
     (define-record-type <json-record>
-      (make-json-record name fields from-json-string accessors mutators)
+      (make-json-record name tag fields from-json-string accessors mutators)
       json-record?
       (name json-record->name)
+      (tag json-record->tag)
       (fields json-record->fields)
       (from-json-string json-record->from-json-string)
       (accessors json-record->accessors)
       (mutators json-record->mutators))
 
+    (define json-record-from-string-allow-missing-keys (make-parameter #f))
+
     (define (json->typeless-json json)
       (cond
        ((json-record? json)