Introduce key: to define-type.

3 files changed, 28 insertions, 8 deletions

diff --git a/doc/ref/guile/util-object.texi b/doc/ref/guile/util-object.texi
index ceac2f2a..1a76160c 100644
--- a/doc/ref/guile/util-object.texi
+++ b/doc/ref/guile/util-object.texi
@@ -61,6 +61,13 @@ Value the field should get if not given.
 A type predicate that the field must obey. See @ref{type-clause} for details.
 @end deffn
 
+@deffn {Field Parameter} key name
+Specifies that the default constructor should take this argument by a
+key other than its own name.
+
+Name should be a bare symbol (not a keyword)!
+@end deffn
+
 @subsection Introduced Bindings
 
 Define type introduces a number procedures. (@var{<name>} should be
diff --git a/module/hnh/util/object.scm b/module/hnh/util/object.scm
index 4477b462..9c95010d 100644
--- a/module/hnh/util/object.scm
+++ b/module/hnh/util/object.scm
@@ -1,4 +1,5 @@
 (define-module (hnh util object)
+  :use-module ((srfi srfi-1) :select (append-map!))
   :use-module (srfi srfi-9 gnu)
   :use-module (ice-9 curried-definitions)
   :use-module (hnh util)
@@ -42,10 +43,7 @@
      (cond ((kv-ref #'(kvs ...) type:)
             => (lambda (type-stx)
                  (with-syntax ((type type-stx))
-                   #'(unless (build-validator-body name type)
-                       (scm-error 'wrong-type-arg "validator"
-                                  "Invalid value for `~s'. Expected ~s, got ~s"
-                                  (list (quote name) (quote type) name) #f)))))
+                   #'(typecheck name type))))
            (else #f)))
     ((_ name) #f)))
 
@@ -114,9 +112,18 @@
 (define (lambda*-stx field)
   (syntax-case field ()
     ((name kvs ...)
-     (cond ((kv-ref #'(kvs ...) default:)
-            => (lambda (dflt) #`(name #,dflt)))
-           (else #'name)))
+     (let ((name (or (kv-ref #'(kvs ...) key:)
+                     #'name)))
+       (cond ((kv-ref #'(kvs ...) default:)
+              => (lambda (dflt) #`(#,name #,dflt)))
+             (else name))))
+    (name #'name)))
+
+(define (name-or-keyname field)
+  (syntax-case field ()
+    ((name kvs ...)
+     (or (kv-ref #'(kvs ...) key:)
+         #'name))
     (name #'name)))
 
 
@@ -150,6 +157,12 @@
                                 (lambda #,(map syntax-first #'(field ...))
                                   (validator field) ...))))
                        (else #`(lambda* (key: #,@(map lambda*-stx #'(field ...)))
+                                 ;; Alias fields for type validator
+                                 #,@(append-map! (lambda (f) (let ((fst (syntax-first f))
+                                                              (rst (name-or-keyname f)))
+                                                          (unless (equal? fst rst)
+                                                            (list #`(define #,fst #,rst)))))
+                                                 #'(field ...))
                                  ;; Type validators
                                  (validator field) ...
                                  (make-<type> #,@(map syntax-first #'(field ...)))))))
diff --git a/tests/test/object.scm b/tests/test/object.scm
index 701c45c0..be6108e5 100644
--- a/tests/test/object.scm
+++ b/tests/test/object.scm
@@ -75,6 +75,6 @@
 (test-error "Bad arguments to custom constructor"
             'wrong-type-arg (f3 f3-x: 'hello f3-y: 'world))
 
-;; - printer:
+;; - printer: (also, zero fields)
 (define-type (f4 printer: (lambda (r p) (display "something" p))))
 (test-equal "something" (with-output-to-string (lambda () (write (f4)))))