>From e0092d786b29f4f1cdc35217212a86804f36cdb4 Mon Sep 17 00:00:00 2001
From: Lars-Dominik Braun <lars@6xq.net>
Date: Fri, 9 Dec 2022 11:46:37 +0100
Subject: [PATCH v2 1/2] packages: Add 'package-upstream-name*'.

* guix/packages.scm (package-upstream-name*): New procedure.
* tests/packages.scm ("package-upstream-name*"): New test.
---
 guix/packages.scm  | 33 +++++++++++++++++++++++++++++++++
 tests/packages.scm |  4 ++++
 2 files changed, 37 insertions(+)

diff --git a/guix/packages.scm b/guix/packages.scm
index 8f119d9fa7..5e8e3a4ff4 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -89,6 +89,7 @@ (define-module (guix packages)
             this-package
             package-name
             package-upstream-name
+            package-upstream-name*
             package-version
             package-full-name
             package-source
@@ -691,6 +692,38 @@ (define (package-upstream-name package)
   (or (assq-ref (package-properties package) 'upstream-name)
       (package-name package)))
 
+(define (package-upstream-name* package)
+  "Return the upstream name of PACKAGE, accounting for commonly-used
+package name prefixes in addition to the @code{upstream-name} property."
+  (let ((namespaces (list "cl-"
+                          "ecl-"
+                          "emacs-"
+                          "ghc-"
+                          "go-"
+                          "guile-"
+                          "java-"
+                          "julia-"
+                          "lua-"
+                          "minetest-"
+                          "node-"
+                          "ocaml-"
+                          "perl-"
+                          "python-"
+                          "r-"
+                          "ruby-"
+                          "rust-"
+                          "sbcl-"
+                          "texlive-"))
+        (name (package-name package)))
+    (or (assq-ref (package-properties package) 'upstream-name)
+        (let loop ((prefixes namespaces))
+          (match prefixes
+            ('() name)
+            ((prefix rest ...)
+              (if (string-prefix? prefix name)
+                (substring name (string-length prefix))
+                (loop (cdr prefixes)))))))))
+
 (define (hidden-package p)
   "Return a \"hidden\" version of P--i.e., one that 'fold-packages' and thus,
 user interfaces, ignores."
diff --git a/tests/packages.scm b/tests/packages.scm
index a5819d8de3..f58c47817b 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -626,6 +626,10 @@ (define read-at
     (build-derivations %store (list drv))
     (call-with-input-file output get-string-all)))
 
+(test-equal "package-upstream-name*"
+  (package-upstream-name* (specification->package "guile-gcrypt"))
+  "gcrypt")
+
 
 ;;;
 ;;; Source derivation with snippets.
-- 
2.37.4