define-record-type/destructor

2 files changed, 17 insertions, 0 deletions

diff --git a/mcgoron.cond-thunk.values.scm b/mcgoron.cond-thunk.values.scm
index ca4469a..8330ba1 100644
--- a/mcgoron.cond-thunk.values.scm
+++ b/mcgoron.cond-thunk.values.scm
@@ -74,3 +74,19 @@
                             (when-ct (null? rest)
                               (apply values whole-list)))))
 
+(define-syntax define-record-type/destructor
+  (syntax-rules ()
+    ((_ type-name cstr predicate? destructor=>
+        (arg-name accessor . rest)
+        ...)
+     (begin
+       (define-record-type type-name
+         str
+         predicate?
+         (arg-name accessor . rest)
+         ...)
+       (define (destructor=> record)
+         (cond-values
+           (after ((when (predicate? record)))
+             (values (accessor record) ...))))))))
+
diff --git a/mcgoron.cond-thunk.values.sld b/mcgoron.cond-thunk.values.sld
index 55f5b22..5597eea 100644
--- a/mcgoron.cond-thunk.values.sld
+++ b/mcgoron.cond-thunk.values.sld
@@ -18,6 +18,7 @@
   (import (scheme base) (mcgoron cond-thunk))
   (export after apply-after
           cond-values
+          define-record-type/destructor
           pair=>
           length-at-least=> length=>)
   (cond-expand